home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagg_m.zip / KEYBOARD.SWG / 0070_Access Keyboard Status By.pas < prev    next >
Pascal/Delphi Source File  |  1994-02-03  |  8KB  |  263 lines
  1.   {========================================================================}
  2.   {                                                                        }
  3.   { If you find these procedures/functions useful, please help support the }
  4.   { SHAREWARE system by sending a small donation ( up to $5 ) to help with }
  5.   { my college education. Reguardless of a donation, use these routines in }
  6.   { good health (and with a clear concious), I hope you find them useful.  }
  7.   {                                                                        }
  8.   {                                                                        }
  9.   { Send Any Replies To:  EUROPA Software                                  }
  10.   {                       314 Pleasant Meadows Dr.                         }
  11.   {                       Gaffney, SC 29340                                }
  12.   {                                                                        }
  13.   { Program: KB_v02                                Last Revised: 11/21/89  }
  14.   {                                                                        }
  15.   { Author: J.E. Clary                                                     }
  16.   {                                                                        }
  17.   { Using ALL of these routines increases the .EXE by only 336 bytes.      }
  18.   {                                                                        }
  19.   { Implementation: Turbo Pascal v.4.0 & v.5.0                             }
  20.   {                                                                        }
  21.   { Purpose:                                                               }
  22.   {                                                                        }
  23.   { This UNIT is to provide direct access to the Keyboard status byte.     }
  24.   { It is intended to use while running under MS-DOS. The unit will not    }
  25.   { function properly, if at all, when running under OS/2. This is because }
  26.   { low-memory access is denied under OS/2 to protect the Operating System.}
  27.   { If you need these functions under OS/2 they are easily accesible by    }
  28.   { calling OS Interrupt 9, which returns status bytes 40:17h and 40:18h   }
  29.   { 'leagally'. The UNIT is written to carry as little excess baggage as   }
  30.   { possible ( only 16 bytes in constants and work variables ) and execute }
  31.   { as fast as possible. This is achieved by directly addressing the key-  }
  32.   { board status byte instead of calling the Operating System.             }
  33.   {                                                                        }
  34.   {=========================   DISCALIMER   ===============================}
  35.   {                                                                        }
  36.   {                                                                        }
  37.   {   These routines are provided AS IS. EUROPA Software, nor any of its   }
  38.   {   employees shall be held liable for any incidental or consequential   }
  39.   {   damage attributed to the use, or inability to use this product.      }
  40.   {                                                                        }
  41.   {                                                                        }
  42.   {========================================================================}
  43.  
  44. unit KB_v02;
  45.  
  46.    INTERFACE
  47.  
  48.    const   Right_Shift     = 0;    { Key_To_Check Constants  }
  49.            Left_Shift      = 1;
  50.            Control_Key     = 2;
  51.            Alt_key         = 3;
  52.  
  53.            Scroll_Lock_Key = 4;    { Key_To_Set Constants    }
  54.            Number_Lock_Key = 5;
  55.            Caps_Lock_Key   = 6;
  56.  
  57.            State_Off       = 0;    {  Action Constants       }
  58.            State_On        = 1;
  59.            State_Toggle    = 2;
  60.  
  61.  
  62.    function Is_Key_Pressed( Key_To_Check  :  byte )  :  boolean;
  63.  
  64.    procedure Set_Keyboard_State( Key_To_Set, Action  :  byte );
  65.    procedure Save_Keyboard_Status;
  66.    procedure Restore_Keyboard_Status;
  67.    procedure Clear_Type_Ahead_Buffer;
  68.  
  69.  
  70.  
  71.    IMPLEMENTATION
  72.  
  73.  
  74.    var Hold_Keyboard_Status, Or_Mask, And_Mask  :  byte;
  75.  
  76.        kb_stat   :  byte absolute $0:$417;  { Keyboard Status Byte }
  77.        tail_buf  :  byte absolute $0:$41C;  { Tail of Circular KB Buffer }
  78.        head_buf  :  byte absolute $0:$41A;  { Head of Circular KB Buffer }
  79.  
  80.  
  81.    procedure Clear_Type_Ahead_Buffer;
  82.  
  83.       begin
  84.  
  85.          tail_buf := head_buf;
  86.  
  87.       end;
  88.  
  89.  
  90.  
  91.    procedure Save_Keyboard_Status;
  92.  
  93.       begin
  94.  
  95.          Hold_Keyboard_Status := kb_stat;
  96.  
  97.       end;
  98.  
  99.  
  100.  
  101.    procedure Restore_Keyboard_Status;
  102.  
  103.       begin
  104.  
  105.          kb_stat := Hold_Keyboard_Status;
  106.  
  107.       end;
  108.  
  109.  
  110.  
  111.    function Is_Key_Pressed( Key_To_Check  :  byte )  :  boolean;
  112.  
  113.       begin
  114.  
  115.          Or_Mask := (1 SHL Key_To_Check);
  116.          Is_Key_Pressed := ((kb_stat AND Or_Mask) = Or_Mask);
  117.  
  118.       end;
  119.  
  120.  
  121.  
  122.    procedure Set_Keyboard_State(  Key_to_Set, Action  :  byte );
  123.  
  124.       begin
  125.  
  126.          Or_Mask  := 1 SHL Key_To_Set;
  127.          And_Mask := (NOT Or_Mask);
  128.  
  129.          case Action of
  130.  
  131.               0: kb_stat := kb_stat AND And_Mask;          {  Off   }
  132.               1: kb_stat := kb_stat OR   Or_Mask;          {  On    }
  133.  
  134.               2: if ( kb_stat AND Or_Mask) = Or_Mask then  { Toggle }
  135.                       kb_stat := (kb_stat AND And_Mask)
  136.                  else kb_stat := (kb_stat  OR  Or_Mask);
  137.  
  138.              end;
  139.  
  140.       end;
  141.  
  142.  
  143.  
  144.    begin  { UNIT Initialization Code }
  145.  
  146.       Hold_Keyboard_Status := 0;
  147.  
  148.    end.
  149.  
  150. { --------------------------  DEMO ----------------------------}
  151.  
  152. program test_KB;
  153.  
  154.    { Demonstates the use of the KB_v02 Unit. }
  155.  
  156.    uses crt, KB_v02;
  157.  
  158.    const on       = 'Key is Pressed   ';
  159.          off      = 'Key isn''t Pressed';
  160.          EveryMsg = 'Any Key to Force ';
  161.          MidMsg   = ' Lock Key to ';
  162.  
  163.          lock_keys   :  array[1..3] of byte =
  164.  
  165.                         ( Number_Lock_Key, Caps_Lock_Key, Scroll_Lock_Key );
  166.  
  167.          key_states  :  array[1..3] of byte =
  168.  
  169.                        ( State_On, State_Off, State_Toggle );
  170.  
  171.  
  172.          key_names    :  array[1..3] of string = ('Number','Caps','Scroll');
  173.          state_names  :  array[1..3] of string = ('On','Off','Toggle');
  174.  
  175.  
  176.  
  177.    var i,j  :  byte;
  178.  
  179.    procedure BurnKey;
  180.  
  181.       var ch  :  char;
  182.  
  183.       begin
  184.  
  185.          ch := readkey;
  186.          if ch = #0 then ch := readkey;
  187.  
  188.       end;
  189.  
  190.    procedure writeAT( x,y  :  byte;  st  :  string );
  191.  
  192.       begin
  193.  
  194.          gotoxy( x,y );
  195.          write( st );
  196.  
  197.       end;
  198.  
  199.  
  200.    begin
  201.  
  202.       clrscr;
  203.       writeln( 'DEMO of Is_Keypressed Function' );
  204.       writeln;
  205.       writeln( ' Any Normal Key to continue ' );
  206.  
  207.       writeAT( 10, 10, 'Alt Key Status'  );
  208.       writeAT( 10, 12, 'CTRL Key Status' );
  209.       writeAT( 10, 14, 'Left Shift Status' );
  210.       writeAT( 10, 16, 'Right Shift Status' );
  211.  
  212.  
  213.       repeat
  214.  
  215.           if Is_Key_Pressed( Alt_Key ) then writeAT( 30,10, on )
  216.           else writeAT( 30,10, off );
  217.  
  218.           if Is_Key_Pressed( Control_Key ) then writeAT( 30,12, on )
  219.           else writeAT( 30,12, off );
  220.  
  221.           if Is_Key_Pressed( Left_Shift ) then writeAT( 30,14, on )
  222.           else writeAT( 30,14, off );
  223.  
  224.           if Is_Key_Pressed( Right_Shift ) then writeAT( 30,16, on )
  225.           else writeAT( 30,16, off );
  226.  
  227.           delay(100);
  228.  
  229.       until keypressed;
  230.  
  231.       clrscr;
  232.  
  233.       burnkey;
  234.       writeln('Keyboard Status Saved' );
  235.       writeln;
  236.  
  237.       Save_Keyboard_Status;
  238.  
  239.       for i := 1 to 3 do begin
  240.  
  241.           for j := 1 to 3 do begin
  242.  
  243.               writeln( EveryMsg, key_names[i], MidMsg, state_names[j] );
  244.               burnkey;
  245.               Set_Keyboard_State( Lock_Keys[i], key_States[j] );
  246.  
  247.           end;
  248.  
  249.           writeln;
  250.  
  251.       end;
  252.  
  253.       writeln;
  254.       writeln( 'End of Demo.' );
  255.       writeln( 'Any Key to Restore Original Lock Status and Exit.' );
  256.  
  257.       BurnKey;
  258.  
  259.       Restore_Keyboard_Status;
  260.  
  261.    end.
  262.  
  263.